home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / dired / dired-rcs.el < prev    next >
Encoding:
Text File  |  1994-12-09  |  7.1 KB  |  197 lines
  1. ;;;; dired-rcs.el - RCS support for Tree Dired
  2.  
  3. (defconst dired-rcs-version (substring "!Revision: 1.6 !" 11 -2)
  4.   "I don't speak RCS-ese")
  5.   
  6. ;; Originally written by Sebastian Kremer <sk@thp.uni-koeln.de>
  7. ;; Rewritten by Heiko Muenkel <muenkel@tnt.uni-hannover.de>
  8.   
  9. ;; Copyright (C) 1991 by Sebastian Kremer <sk@thp.uni-koeln.de>
  10. ;; Copyright (C) 1994 by Heiko Muenkel <muenkel@tnt.uni-hannover.de>
  11.  
  12. ;; This program is free software; you can redistribute it and/or modify
  13. ;; it under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 1, or (at your option)
  15. ;; any later version.
  16. ;;
  17. ;; This program is distributed in the hope that it will be useful,
  18. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;; GNU General Public License for more details.
  21. ;;
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with this program; if not, write to the Free Software
  24. ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  25.  
  26. ;; INSTALLATION ======================================================
  27. ;; 
  28. ;; This will not work with classic (18.xx) Dired, you'll need Tree Dired,
  29. ;; available via anonymous ftp from
  30. ;; 
  31. ;;     ftp.thp.Uni-Koeln.DE[134.95.64.1]:/pub/gnu/emacs/diredall.tar.Z
  32. ;;
  33. ;; Put this file into your load-path and the following in your ~/.emacs:
  34. ;; 
  35. ;;   (autoload 'dired-rcs-mark-rcs-locked-files "dired-rcs")
  36. ;;   (autoload 'dired-rcs-mark-rcs-files "dired-rcs")
  37. ;;
  38. ;; Put this inside your dired-load-hook:
  39. ;; 
  40. ;;   (define-key dired-mode-map "," 'dired-rcs-mark-rcs-files)
  41. ;;   (define-key dired-mode-map "\M-," 'dired-rcs-mark-rcs-locked-files)
  42. ;;
  43.  
  44. (require 'dired)
  45.  
  46. ;;;###autoload
  47. (defun dired-rcs-mark-rcs-locked-files (&optional unflag-p)
  48.   "Mark all files that are under RCS control and RCS-locked.
  49. With prefix argument, unflag all those files.
  50. Mentions RCS files for which a working file was not found in this buffer.
  51. Type \\[dired-why] to see them again."
  52.   (interactive "P")
  53.   (dired-rcs-mark-rcs-files unflag-p t))
  54.  
  55. ;;;###autoload
  56. (defun dired-rcs-mark-rcs-files (&optional unflag-p locked)
  57.   "Mark all files that are under RCS control.
  58. With prefix argument, unflag all those files.
  59. Mentions RCS files for which a working file was not found in this buffer.
  60. Type \\[dired-why] to see them again."
  61.   ;; Returns list of failures, or nil on success.
  62.   ;; Optional arg LOCKED means just mark RCS-locked files.
  63.   (interactive "P")
  64.   (message "%s %sRCS controlled files..."
  65.        (if unflag-p "Unmarking" "Marking")
  66.        (if locked "locked " ""))
  67.   (let ((dired-marker-char (if unflag-p ?\  dired-marker-char))
  68.     rcs-files wf failures count total)
  69.     ;; Loop over subdirs to set `rcs-files'
  70.     (mapcar
  71.      (function
  72.       (lambda (dir)
  73.     (or (equal (file-name-nondirectory (directory-file-name dir))
  74.            "RCS")
  75.         ;; skip inserted RCS subdirs
  76.         (setq rcs-files
  77.           (append (if locked
  78.                   ;; these two functions from sk's rcs.el
  79.                   (rcs-locked-files dir)
  80.                 (rcs-files dir))
  81.               rcs-files)))))
  82.      (mapcar (function car) dired-subdir-alist))
  83.     (setq total (length rcs-files))
  84.     (while rcs-files
  85.       (setq wf (rcs-working-file (car rcs-files))
  86.         rcs-files (cdr rcs-files))
  87.       (save-excursion (if (dired-goto-file wf)
  88.               (dired-mark-file 1)
  89.             (dired-log "RCS working file not found: %s\n" wf)
  90.             (setq failures (cons (dired-make-relative wf)
  91.                          failures)))))
  92.     (if (null failures)
  93.     (message "%d %sRCS file%s %smarked."
  94.          total
  95.          (if locked "locked " "")
  96.          (dired-plural-s total)
  97.          (if unflag-p "un" ""))
  98.       (setq count (length failures))
  99.       (dired-log-summary "RCS working file not found %s" failures)
  100.       (message "%d %sRCS file%s: %d %smarked - %d not found %s."
  101.            total
  102.            (if locked "locked " "")
  103.            (dired-plural-s total) (- total count)
  104.            (if unflag-p "un" "") count failures))
  105.     failures))
  106.  
  107. (defun rcs-files (directory)
  108.   "Return list of RCS data files for all RCS controlled files in DIRECTORY."
  109.   (setq directory (file-name-as-directory directory))
  110.   (let ((rcs-dir (file-name-as-directory (expand-file-name "RCS" directory)))
  111.     (rcs-files (directory-files directory t ",v$")))
  112.     (if (file-directory-p rcs-dir)
  113.     (setq rcs-files
  114.           (append (directory-files rcs-dir t ",v$")
  115.               rcs-files)))
  116.     rcs-files))
  117.  
  118. (defvar rcs-output-buffer "*RCS-output*"
  119.   "If non-nil, buffer name used by function `rcs-get-output-buffer' (q.v.).
  120. If nil, a new buffer is used each time.")
  121.  
  122. (defun rcs-get-output-buffer (file)
  123.   ;; Get a buffer for RCS output for FILE, make it writable and clean
  124.   ;; it up.  Return the buffer.
  125.   ;; The buffer used is named according to variable
  126.   ;; `rcs-output-buffer'.  If the caller wants to be reentrant, it
  127.   ;; should let-bind this to nil: a new buffer will be chosen. 
  128.   (let* ((default-major-mode 'fundamental-mode);; no frills!
  129.      (buf (get-buffer-create (or rcs-output-buffer "*RCS-output*"))))
  130.     (if rcs-output-buffer
  131.     nil
  132.       (setq buf (generate-new-buffer "*RCS-output*")))
  133.     (save-excursion
  134.       (set-buffer buf)
  135.       (setq buffer-read-only nil
  136.         default-directory (file-name-directory (expand-file-name file)))
  137.       (erase-buffer))
  138.     buf))
  139.  
  140. (defun rcs-locked-files (directory)
  141.   "Return list of RCS data file names of all RCS-locked files in DIRECTORY."
  142.   (let ((output-buffer (rcs-get-output-buffer directory))
  143.     (rcs-files (rcs-files directory))
  144.     result)
  145.     (and rcs-files
  146.      (save-excursion
  147.        (set-buffer output-buffer)
  148.        (apply (function call-process) "rlog" nil t nil "-L" "-R" rcs-files)
  149.        (goto-char (point-min))
  150.        (while (not (eobp))
  151.          (setq result (cons (buffer-substring (point)
  152.                           (progn (forward-line 1)
  153.                              (1- (point))))
  154.                 result)))
  155.        result))))
  156.  
  157. (defun rcs-working-file (filename)
  158.   "Convert an RCS file name to a working file name.
  159. That is, convert `...foo,v' and `...RCS/foo,v' to `...foo'.
  160. If FILENAME doesn't end in `,v' it is returned unchanged."
  161.   (if (not (string-match ",v$" filename))
  162.       filename
  163.     (setq filename (substring filename 0 -2))
  164.     (let ((dir (file-name-directory filename)))
  165.       (if (null dir)
  166.       filename
  167.     (let ((dir-file (directory-file-name dir)))
  168.       (if (equal "RCS" (file-name-nondirectory dir-file))
  169.           ;; Working file for ./RCS/foo,v is ./foo.
  170.           ;; Don't use expand-file-name as this converts "" -> pwd
  171.           ;; and thus forces a relative FILENAME to be relative to
  172.           ;; the current value of default-directory, which may not
  173.           ;; what the caller wants.  Besides, we want to change
  174.           ;; FILENAME only as much as necessary.
  175.           (concat (file-name-directory dir-file)
  176.               (file-name-nondirectory filename))
  177.         filename))))))
  178.  
  179. (defun dired-do-vc-register (&optional arg)
  180.   "Register the marked (or next ARG) files under version control."
  181.   (interactive "P")
  182.   (dired-mark-map-check (function dired-vc-register) arg 'register t))
  183.  
  184. (defun dired-vc-register ()
  185.   (let ((file (dired-get-filename)) failure)
  186.     (condition-case err
  187.     (save-window-excursion
  188.       (find-file file)
  189.       (vc-register))
  190.       (error (setq failure err)))
  191.     (if (not failure)
  192.     nil
  193.       (dired-log "Register error for %s:\n%s\n" file failure)
  194.       (dired-make-relative file))))
  195.     
  196. (provide 'dired-rcs)
  197.